home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DIRS.SWG / 0033_GIF Directory.pas < prev    next >
Pascal/Delphi Source File  |  1994-08-24  |  16KB  |  440 lines
  1. Program GIFDIR(Input, Output);
  2.  
  3. Uses Dos, Crt;
  4.  
  5. Const
  6.   ProSoft = ' Gif DIRectory - Version 2.0 (C) ProSoft '+Chr(254)+' Phil R. Overman 02-02-92';
  7.   gifliteheader                       = chr($21)+chr($FF)+chr(11)+'GIFLITE';
  8.   giflitesearch                       = 100;
  9.   ScreenLines                         = 23;
  10.   Maxlinelength                       = 80;
  11.   test0                               = false;
  12.   test1                               = true;
  13. (*
  14.     {$I-}
  15. *)
  16. Type
  17.   String12                            = String[12];
  18.   LineType                            = Packed Array[1..Maxlinelength] of char;
  19.   LengthType                          = 0..Maxlinelength;
  20.   String2                             = String[2];
  21.   String3                             = String[3];
  22.   String8                             = Packed Array[1..8] of char;
  23. { String12                            = Packed Array[1..12] of char; }
  24.   String15                            = String[15];
  25.  
  26. Var
  27.   dodate, dotime, domegs, doextension : boolean;
  28.   doversion, dopalette, doGCT         : boolean;
  29.   dofiledot, doall, dogiflite         : boolean;
  30.   CmtFound, Pause, ShowZips, isgif    : Boolean;
  31.   CmtSize, FileCount, LinesWritten    : Word;
  32.   attr, height, width, colors         : Word;
  33.   fileattr                            : word;
  34.   TotalSize, position                 : Longint;
  35.   filesize, filedate                  : longint;
  36.   icount, jcount                      : integer;
  37.   count, clen                         : Byte;
  38.   megs                                : real;
  39.   DirInfo, gifdirinfo                 : Searchrec;
  40.   Path, Gifpath, filein               : PathStr;
  41.   Dir                                 : DirStr;
  42.   Name, infdatestring, gifname        : NameStr;
  43.   Ext                                 : ExtStr;
  44.   A, B, C, cc, ch, eoname             : Char;
  45.   Abyte                               : Byte;
  46.   cs                                  : String[1];
  47.   meg                                 : String2;
  48.   gversion, gheader                   : String3;
  49.   filename                            : String[12];
  50.   infile, outfile                     : text;
  51.   giffile                             : file;
  52.   infdt, filedt                       : datetime;
  53.   giffilein                           : String15;
  54.   Drive                               : String2;
  55.   GCTF                   {1 Bit}      : boolean;
  56.   ColorResolution        {3 Bits}     : byte;
  57.   SortFlag               {1 Bit}      : boolean;
  58.   SizeOfGCT              {3 Bits}     : byte;
  59.   giflite                             : boolean;
  60.   BackgroundColorIndex                : Byte;
  61.   PixelAspectRatio                    : Byte;
  62.   SizeofPalette                       : Longint;
  63. { Cmt                                 : CmtType; }
  64. (***************************************************************)
  65. Procedure BadParms;
  66. begin
  67.   writeln(' Program syntax: GDIR [d:\Path][Filename[.GIF]] [/p/a/d/t/m/f/v/g/r/?|h]');
  68. {  writeln; }
  69.   writeln(' Displays standard DOS DIR of GIF files, but with height, width, and colors');
  70. {  writeln; }
  71.   writeln(' Output looks like this (with no parameters):');
  72. {  writeln; }
  73.   writeln(' GIFNAME  GIF   178152   5-11-91  640h 400w 256c');
  74.   writeln;
  75.   { writeln('Enter *.* to display all files (normal Dir).'); }
  76.   writeln(' Parameters:');
  77.   writeln(' /P Pauses the display, just as in the DOS Dir command.');
  78.   writeln(' /A Displays complete information, except time.');
  79.   writeln(' /D turns display of the file Date off.');
  80.   writeln(' /T turns display of the file Time on.');
  81.   writeln(' /M shows size in Megabytes instead of bytes.');
  82.   writeln(' /F displays GIFNAME.GIF instead of GIFNAME  GIF');
  83.   writeln(' /E suppress display of the extension.');
  84.   writeln(' /G Check if file optimized by GIFLITE and display it if so.');
  85.   writeln(' /V displays the Version of the GIF file - GIF87a, GIF89a, etc.');
  86.   writeln(' /C displays "GCM" if the file has a Global Color Map');
  87.   writeln(' /R Resolution - displays the total number of colors in the pallette');
  88.   writeln(' /H or /? displays this Help screen.');
  89.   if Doserror >  0 then writeln;
  90.   If Doserror = 18 then Writeln(' File not found');
  91.   If Doserror =  3 then writeln(' Path not found');
  92.   if Doserror >  0 then writeln;
  93.   halt(98);
  94. end;
  95. (************************************************)
  96. Procedure FlipB(Var f : boolean);
  97. Begin
  98.   If f then f := false else f := true;
  99. End;
  100. (************************************************)
  101. Procedure ProcessParms(s : string);
  102. var sr : searchrec;
  103. Begin
  104.   If (pos('/',s) = 1) Then
  105.     Begin
  106.       If (Copy(s,2,1) = 'P') or (Copy(s,2,1) = 'p') then Pause := true;
  107.       If (Copy(s,2,1) = 'D') or (Copy(s,2,1) = 'd') then Flipb(dodate);
  108.       If (Copy(s,2,1) = 'T') or (Copy(s,2,1) = 't') then Flipb(dotime);
  109.       If (Copy(s,2,1) = 'M') or (Copy(s,2,1) = 'm') then Flipb(domegs);
  110.       If (Copy(s,2,1) = 'F') or (Copy(s,2,1) = 'f') then Flipb(dofiledot);
  111.       If (Copy(s,2,1) = 'V') or (Copy(s,2,1) = 'v') then Flipb(doversion);
  112.       If (Copy(s,2,1) = 'R') or (Copy(s,2,1) = 'r') then Flipb(dopalette);
  113.       If (Copy(s,2,1) = 'G') or (Copy(s,2,1) = 'g') then Flipb(dogiflite);
  114.       If (Copy(s,2,1) = 'C') or (Copy(s,2,1) = 'c') then Flipb(doGCT);
  115.       If (Copy(s,2,1) = 'E') or (Copy(s,2,1) = 'e') then Flipb(doextension);
  116.       If (Copy(s,2,1) = 'A') or (Copy(s,2,1) = 'a') then
  117.         Begin
  118.           Flipb(doall);
  119.           dodate := true; dotime := false; dofiledot := false;
  120.           domegs := false; doversion := true; dopalette := false;
  121.           doGCT := true; doextension := true; dogiflite := true;
  122.         End;
  123.       If (Copy(s,2,1) = 'H') or (Copy(s,2,1) = 'h') or (Copy(s,2,1) = '?') then Badparms;
  124.     End
  125.   Else
  126.     Begin
  127.       Path := FExpand(s);
  128. {      If Copy(Path,Length(Path),1) = '\' then Path := Path + '*.GIF'; }
  129. {      If Pos('.',path) = 0 then path := path + '.GIF'; }
  130. {      If Pos('*',Path) + Pos('?',path) + Pos('.GIF',path) = 0
  131.         then
  132.           begin
  133.             FindFirst(Path,$10,sr);
  134.             If Doserror = 0 then Path := Path + '\*.gif';
  135.           end; }
  136.     End;
  137. End;
  138. (*******************)
  139. Function Exponential(A:integer; B:byte):longint;
  140. Var yyy : longint;
  141. (* Returns A to the Bth *)
  142. Begin
  143.   yyy := A;
  144.   For count := 2 to B Do yyy := yyy * A;
  145.   If b=0 then Exponential := 1 else Exponential := yyy;
  146. End;
  147. (**********************************)
  148. Function BV(A:byte; b:byte):byte; {BitValue}
  149. var aa : byte;
  150. (* A is the byte value - b is the bit # for which the value is desired 1-8 *)
  151. Begin
  152.   aa := a;
  153.   While aa >= Exponential(2,b) do dec(aa,Exponential(2,b));
  154.   If aa < Exponential(2,b-1) then BV := 0 else BV := 1;
  155. End;
  156. (***********************)
  157. Procedure ClearName;
  158. Begin
  159.   For count := 1 to 12 do DirInfo.name[count] := ' ';
  160. End;
  161. (**************************)
  162. Procedure ClearABC;
  163. Begin
  164.   A := ' '; B := ' '; C := ' ';
  165. End;
  166. (*******************)
  167. {
  168. Procedure ClearCmt;
  169. Begin
  170.   CmtFound := False;
  171.   for count := 1 to MaxCmtSize do Cmt[count] := ' ';
  172. End;
  173. }
  174. (*******************)
  175. Procedure WriteName(n : String12);
  176. Var p, q, qq, r : byte;
  177. Begin
  178.   p := 0;  q := 0;  r := 0;
  179.   If doextension then qq :=12 else qq := 8;
  180.   While r < length(n) DO
  181.     Begin
  182.       inc(p);
  183.       inc(r);
  184.       if (n[p] = '.') and not dofiledot
  185.         then
  186.           Begin
  187.               If p < 9 then write(' ':9-p);
  188.               inc(q, 9-p);
  189.               If doextension then
  190.                 Begin
  191.                   write(' ');
  192.                   inc(q);
  193.                 End;
  194.           End
  195.         else
  196.             begin
  197.               If (p<9) or doextension then
  198.                 begin
  199.                   write(n[p]);
  200.                   inc(q);
  201.                 end;
  202.             end;
  203.     End;
  204.   If q < qq then write(' ':qq-q);
  205. End;
  206. (********************************)
  207. Procedure WriteDate(i : longint);
  208. Var d : datetime;
  209. Begin
  210.   Unpacktime(i,d);
  211.   If d.month > 9 then Write(d.month,'-') else Write('0',d.month,'-');
  212.   If d.day > 9 then Write(d.day) else Write('0',d.day);
  213.   Write('-',d.year mod 100);
  214.   Write(' ');
  215. End;
  216. (********************************)
  217. Procedure WriteTime(i : longint);
  218. Var d : datetime;
  219. Begin
  220.   Unpacktime(i,d);
  221.   Write(' ');
  222.   if d.hour = 0 then Write('12') else if d.hour mod 12 > 9 then Write(d.hour mod 12) else write(' ',d.hour mod 12);
  223.   if d.min = 0 then Write(':00') else if d.min > 9 then write(':',d.min) else Write(':0',d.min);
  224.   If d.hour > 11 then Write('p ') else Write('a ');
  225. End;
  226. (*****************************************************)
  227. Procedure Writeline(s : Searchrec);
  228. Var xx : byte; ss: string[1];
  229. Begin
  230.   Writename(s.name);
  231.   If domegs or doextension then
  232.     Begin
  233.       xx := (s.size+5120) div 10240;
  234.       If xx < 10
  235.         then
  236.           begin
  237.             Str(xx:1, ss);
  238.             meg := '0' + ss
  239.           end
  240.         else
  241.           Str(xx:2, meg)
  242.     End;
  243.   If domegs    then Write('  .',meg,' ') else Write(s.size:10);
  244.                     Write(' ');
  245.   If dodate    then Writedate(s.time);
  246.   If dotime    then WriteTime(s.time);
  247.   If isgif     then
  248.     Begin
  249.       Write(height:4,'h',width:4,'w',colors:4,'c ');
  250.       If dopalette then Write(sizeofpalette,'R ');
  251.       If doversion then Write (' ',gversion,' ');
  252.       If doGCT then begin if GCTF then Write(' GCM ') else write('     ') end;
  253.       If doGIFLITE then begin if GIFLITE then Write(' GL ') else write(' ng ') end;
  254.     End;
  255.   Writeln;
  256. End;
  257. (****************************************************)
  258. Procedure ProcessGifFile;
  259. Var result : word;
  260. BEGIN
  261.   Assign(GifFile, Concat(Dir,DirInfo.name));
  262.   Reset(GifFile, 1);
  263.   isgif := false;
  264.   inc(filecount);
  265.   inc(totalsize,dirinfo.size);
  266.   ClearABC;
  267. (* See if it's a GIF file. *)
  268.   Result := Pos('.',Dirinfo.name);
  269.   If (result > 0) and
  270.     (Copy(DirInfo.name,result,Length(DirInfo.name)-result+1) = '.GIF')
  271.     then isgif := true;
  272. {  Result := Filesize; }
  273.   If isgif { and (result>12) }
  274.     then
  275.       Begin
  276.         blockread(GifFile, A, 1, result);
  277.         blockread(GifFile, B, 1, result);
  278.         blockread(GifFile, C, 1, result);
  279.         gheader := A + B + C;
  280.       End;
  281.   If gheader = 'GIF'
  282.     Then
  283.       Begin {GifFileFound!}
  284.         blockread(GifFile, A, 1, result);
  285.         blockread(GifFile, B, 1, result);
  286.         blockread(GifFile, C, 1, result);
  287.         gversion := A + B + C;
  288.         blockread(GifFile, height, 2, result);
  289.         blockread(GifFile, width, 2, result);
  290.         blockread(GifFile, Abyte, 1, result);
  291.         SizeOfGCT := BV(Abyte,1) + BV(Abyte,2)*2 + BV(Abyte,3)*4 +1;
  292.         colors := Exponential(2,SizeOfGCT);
  293.         If BV(Abyte,4) = 1 then SortFlag := true else SortFlag := false;
  294.         ColorResolution := BV(Abyte,5) + BV(Abyte,6)*2 + BV(Abyte,7)*4 +1;
  295.         SizeOfPalette := Exponential(2,ColorResolution);
  296.         SizeOfPalette := Exponential(SizeofPalette,3);
  297.         If BV(Abyte,8) = 1 then GCTF := true else GCTF := false;
  298.         Blockread(GifFile, BackgroundColorIndex, 1);
  299.         Blockread(GifFile, PixelAspectRatio, 1);
  300.         If dogiflite
  301.           then
  302.             Begin
  303.               giflite := false;
  304.               icount := 0;
  305.               count := 1;
  306.               jcount := giflitesearch;
  307.               If GCTF then inc(jcount,3*colors);
  308.               While (icount < jcount) and not giflite do
  309.                 Begin
  310.                   Blockread(Giffile, A, 1, result);
  311.                   If A = Copy(gifliteheader, count, 1) then
  312.                     Begin
  313.                       If count = length(gifliteheader)
  314.                         then
  315.                            giflite := true
  316.                         else
  317.                           inc(count)
  318.                     End;
  319.                   Inc(icount);
  320.                 End;
  321.             End;
  322.       End;
  323.   Writeline(DirInfo);
  324.   Close(GifFile);
  325.   Inc(LinesWritten);
  326. END;
  327. (**********************)
  328. Procedure WriteVolLabel;
  329. Var v : searchrec; c : byte;
  330. Begin
  331.   FindFirst(Copy(Path,1,3)+'*.*',VolumeID,v);
  332.   Write(' Volume in drive ',Copy(Path,1,1),' is ');
  333.   For c := 1 to length(v.name) do if v.name[c] <> '.' then write(v.name[c]);
  334.   Writeln;
  335.   Write(' Directory of ',Copy(Dir,1,Length(Dir)-1));
  336.   If Copy(Dir,2,1) = ':' then Write('\');
  337.   Writeln;
  338.   Writeln;
  339. End;
  340. (***************************************)
  341. Procedure ParseParms(pps : string);
  342. Begin { This only gets parms with a slash / in them. }
  343. If Pos('/',pps) <> 1 Then { This is the filename with a slash appended }
  344.   Begin
  345. {    ProcessParms(Copy(pps,1,Pos('/',pps)-1)); }
  346.     Path := Fexpand(Copy(pps,1,Pos('/',pps)-1));
  347.     pps := Copy(pps,Pos('/',pps),Length(pps)-Pos('/',pps)+1)
  348.   End;
  349. While (Pos('/',pps) > 0) and (Length(pps) > 1) Do
  350.   Begin
  351.     ProcessParms(Copy(pps,1,2));
  352.     pps := Copy(pps,2,Length(pps)-1);
  353.     If Pos('/',pps) > 0 then
  354.       pps := Copy(pps,Pos('/',pps),Length(pps)-Pos('/',pps)+1);
  355.   End;
  356. End;
  357. (***************************************)
  358. Procedure Initialize;
  359. Var sr : searchrec;
  360. Begin
  361.   Assign(Input,'');   Reset(Input);
  362.   Assign(Output,'');  Rewrite(Output);
  363.   Writeln;
  364.   Writeln(ProSoft);
  365.   Writeln;
  366.   dodate := true;  dotime := false;  domegs := false;  doextension := true;
  367.   dopalette := false; doGCT := false; doversion := false; pause := false;
  368.   dofiledot := false; dogiflite := true; doall := false;
  369.   gheader := '  '; gversion := '   ';
  370.   ClearABC; Clearname;
  371.   FileCount := 0;  TotalSize := 0;  LinesWritten := 0;
  372.   For count := 1 to Sizeof(path) do Path[count] := ' ';
  373.   For count := 1 to Sizeof(Dir)  do Dir[count]  := ' ';
  374.   For Count := 1 to Sizeof(Name) do Name[count] := ' ';
  375.   For count := 1 to Sizeof(Ext)  do Ext[count]  := ' ';
  376.   If paramcount = 0
  377.     then
  378.       Path := FExpand('*.GIF')
  379.     else
  380.       If Pos('/',paramstr(1)) = 1 then path := FExpand('*.GIF');
  381.       For Count := 1 to paramcount do If Pos('/',paramstr(count)) > 0
  382.         then
  383.           ParseParms(paramstr(count))
  384.         else
  385.           Path := Fexpand(paramstr(count));
  386. {
  387.   FindFirst(Path,$10,sr);
  388.   If (Doserror = 0) and (sr.attr = $10) then
  389.     begin
  390.       Path := Path + '\*.gif';
  391.       Path := FExpand(Path)
  392.     end;
  393. }
  394.   Fsplit(Path,Dir,Name,Ext);
  395.   If (name = '') or (name = '        ') then name := '*';
  396.   If (Ext = '') or (Ext = '    ') then Ext := '.GIF';
  397.   Path := Dir + Name + Ext;
  398. End;
  399. (******************> Main <*********************)
  400. Begin    { Main }
  401.   Initialize;
  402.   FindFirst(Path,$21,DirInfo);
  403.   If Doserror = 0
  404.     then
  405.       Begin
  406.         WriteVolLabel;
  407.         While DosError < 1 do
  408.           Begin
  409.             If (dirinfo.name = '.') or (dirinfo.name = '..')
  410.               then
  411.                 For count := 1 to 12 do DirInfo.name[count] := ' '
  412.               else
  413.                 ProcessGifFile;
  414.             FindNext(DirInfo);
  415.             If pause and (LinesWritten = ScreenLines) and (DosError < 1)
  416.               then
  417.                 Begin
  418.                   Writeln('Press any key to continue . . .');
  419.                     AssignCrt(Input);   Reset(Input);
  420.                     AssignCrt(Output);  Rewrite(Output);
  421.                   ch := Readkey;
  422.                     Assign(Input,'');   Reset(Input);
  423.                     Assign(Output,'');  Rewrite(Output);
  424.                   Writeln;
  425.                   LinesWritten := 1;
  426.                 End;
  427.           End;
  428.         Write(FileCount:9,' file');
  429.         If Filecount = 1 then Write('  ') else Write('s ');
  430.         cs := Copy(Path,1,1);
  431.         cc := cs[1];
  432.         count := ord(cc)-64;
  433.         Writeln(totalsize:12,' bytes');
  434.         Writeln(' ':16,diskfree(count):12,' bytes free ');
  435.         Writeln;
  436.       End
  437.     Else
  438.       Badparms;
  439. End.
  440.